home *** CD-ROM | disk | FTP | other *** search
/ The 640 MEG Shareware Studio 2 / The 640 Meg Shareware Studio CD-ROM Volume II (Data Express)(1993).ISO / prog / pistol.zip / PISTD.C < prev    next >
Text File  |  1987-08-20  |  5KB  |  273 lines
  1. /*********************************************************/
  2. /*                             */
  3. /* PISTOL-Portably Implemented Stack Oriented Language     */
  4. /*            Version 1.3             */
  5. /* (C) 1982 by    Ernest E. Bergmann             */
  6. /*        Physics, Building #16             */
  7. /*        Lehigh Univerisity             */
  8. /*        Bethlehem, Pa. 18015             */
  9. /*                             */
  10. /* Permission is hereby granted for all reproduction and */
  11. /* distribution of this material provided this notice is */
  12. /* is included.                         */
  13. /*                             */
  14. /*********************************************************/
  15.  
  16. /* fourth module, February, 1982 */
  17.  
  18. #include "bdscio.h"
  19. #include "pistol.h"
  20.  
  21. interpret(i)
  22. unsigned i;
  23. {    instr=i;
  24.     do    {ip += W;
  25.         if(instr<(RESTOR+1)) /*pint(instr);*/
  26.                 (*farray[instr])();
  27.         else    { rpush(ip); ip=instr;}
  28.         Pw = ip;
  29.         instr=*Pw;
  30.         /* trace patch here */
  31.         if(rptr==(ram[-19].in-2))
  32.             {savinstr=instr;
  33.             savlevel=rptr;
  34.             instr=ram[-26].in;
  35.             ip -= W;
  36.             do    {ip += W;
  37.                 if(instr<(RESTOR+1))
  38.                     /*pint(instr);*/
  39.                     (*farray[instr])();
  40.                 else{rpush(ip); ip=instr;}
  41.                 Pw=ip; instr=*Pw;
  42.                 }
  43.             while( rptr > savlevel);
  44.             instr=savinstr;
  45.             }
  46.         }
  47.     while (rptr >= 0);
  48.     ip -= W;
  49. }
  50.  
  51. fname(name)    /*name[0]=length,name[length+1]=0*/
  52. char name[NAMESIZE];
  53. {    drop(); Pc=stack[1+stkptr];
  54.     movmem(1+Pc,1+name,*Pc); name[1+*Pc]='\0';
  55.     name[0]=*Pc;
  56. }
  57.  
  58. rewrit(name,iobuf)
  59. char name[NAMESIZE],*iobuf;
  60. {    if(stkptr<1)merr(undflo);
  61.     if(name[0])
  62.         {if(ram[-24].in) carret();
  63.         message(redef);message(name);carret();
  64.         closout(iobuf);
  65.         }
  66.     fname(name);
  67.     if(0>fcreat(1+name,iobuf))
  68.     {    if(ram[-24].in) carret();
  69.         message(name);
  70.         merr(nopen);
  71.     }
  72. }
  73.  
  74. beginop()
  75. { pushck('B'); push(ram[-2].in); }
  76.  
  77. endop()
  78. {    if(strings[1+strings[1]]=='B')
  79.         {dropck(); compile(PIF);
  80.         compile(stack[stkptr]-ram[-2].in);
  81.         drop();
  82.         }
  83.     else synterr();
  84. }
  85.  
  86. repet()
  87. {    Pc=&strings[1]+strings[1];Pc2=Pc-1;
  88.     dropck();dropck();
  89.     if((*Pc=='F') && (*Pc2=='B'))
  90.         {compile(PELSE);
  91.         compile(stack[stkptr-1]-ram[-2].in);
  92.         touchup(); drop();
  93.         }
  94.     else synterr();
  95. }
  96.  
  97. pdollar()
  98. {    enter(); Pw=ip;
  99.     move(ip+W,ram[-3].pw,*Pw-W);
  100.     Pw=ip;ram[-3].in += *Pw-W;
  101.     fenter(ram[-3].in-W);
  102.     Pw=ram[-6].pw;Pw=*Pw;Pw--;
  103.     *Pw=COMPME;
  104.     permstrings();
  105.     Pw=ip;ip += *Pw;
  106. }
  107.  
  108. pcolon()
  109. {    enter(); Pw=ip;
  110.     move(ip+W,ram[-3].pw,*Pw-W);
  111.     Pw=ip;ram[-3].in += *Pw-W;
  112.     fenter(ram[-3].in-W);
  113.     permstrings(); Pw=ip;
  114.     ip += *Pw;
  115. }
  116.  
  117. casat()
  118. {    enter();
  119.     if(cptr<stack[stkptr+1]) abort();
  120.     push(cstack[cptr-stack[stkptr+1]]);
  121. }
  122.  
  123. pploop()
  124. { drop(); lstack[lptr]+=stack[stkptr+1]; aloop(); }
  125.  
  126. plloop()
  127. {    if(strings[1+strings[1]]=='D')
  128.         {dropck(); compile(PPLOOP);
  129.         compile(stack[stkptr]-ram[-2].in+W);
  130.         touchup();
  131.         }
  132.     else synterr();
  133. }
  134.  
  135. cat()
  136. { Pc=stack[stkptr];stack[stkptr]=*Pc; }
  137.  
  138. cstore()
  139. {    Pc=stack[stkptr];drop();
  140.     i=stack[stkptr];drop();
  141.     *Pc=i;
  142. }
  143.  
  144. ploop()
  145. { lstack[lptr]++;aloop(); }
  146.  
  147. gt()
  148. {    drop();drop();
  149.     if(stack[stkptr+1] >stack[stkptr+2]) push(TRU);
  150.     else push(FALS);
  151. }
  152.  
  153. semidol()
  154. {    if(strings[1+strings[1]]=='$')
  155.         {dropck(); compile(PSEMICOLON);
  156.         touchup();
  157.         }
  158.     else synterr();
  159. }
  160.  
  161. kernq()
  162. {    drop();
  163.     if(stack[stkptr+1]<ram[-55].in)    push(TRU);
  164.     else push(FALS);
  165. }
  166.  
  167. sat()
  168. {    if(stack[stkptr]<stkptr-1)
  169.         {stack[stkptr]=stack[stkptr-stack[stkptr]-1];}
  170.     else merr(undflo);
  171. }
  172.  
  173. findop()
  174. { drop();push(find(stack[1+stkptr])); }
  175.  
  176. listfil()
  177. { rewrit(listname,list); }
  178.  
  179. lat()
  180. {    drop();
  181.     if(lptr<stack[stkptr+1]) abort();
  182.     push(lstack[lptr-stack[stkptr+1]]);
  183. }
  184.  
  185. ofcas()
  186. { pushck('C'); compile(POFCAS);    fwdref(); }
  187.  
  188. ccolon()
  189. {    if(strings[1+strings[1]]=='C')
  190.         {pushck('c');compile(PCCOL);fwdref();}
  191.     else synterr();
  192. }
  193.  
  194. semicc()
  195. {    if(strings[1+strings[1]]=='c')
  196.         {dropck();compile(PSEMICC);touchup();}
  197.     else synterr();
  198. }
  199.  
  200. ndcas()
  201. {    if(strings[1+strings[1]]=='C')
  202.         {dropck();compile(ram[-25].in);touchup();}
  203.     else synterr();
  204. }
  205.  
  206. pofcas()
  207. {    drop(); stkptr++; Pw=ip;
  208.     cpush(ip+ *Pw);cpush(stack[stkptr]);
  209.     ip += W;
  210. }
  211.  
  212. strange()
  213. { Printf("strange opcode:%d\n",instr); abort(); }
  214.  
  215. pccol()
  216. {    drop();
  217.     if(stack[stkptr+1]) ip += W;
  218.     else    {push(cstack[cptr]);
  219.         Pw=ip; ip += *Pw;
  220.         }
  221. }
  222.  
  223. psemicc()
  224. {    cptr -= 2;
  225.     if(cptr<0) abort();
  226.     ip=cstack[cptr+1];
  227. }
  228.  
  229. openr()
  230. {    fname(namein);
  231.     if(fopen(1+namein,edin)==ERROR)
  232.         {printf("\nCAN'T OPEN:%s",1+namein);abort();}
  233.     ram[-30].in=0;
  234. }
  235.  
  236. openw()
  237. {    rewrit(namout,edout);
  238.     ram[-31].in=0;
  239. }
  240.  
  241. readl()
  242. {    ram[-16].in=0; /* Feb 19 */
  243.     ram[-15].pc=&strings[1+LINEBUF];
  244.     if(ram[-30].in<0) merr(feof);
  245.     finline(edin,&ram[-30].in);
  246.     ram[-30].in++;
  247.     if(eof(edin)) ram[-30].in=-ram[-30].in;
  248.     if(ram[-13].in) message(&strings[LINEBUF]);
  249. }
  250.  
  251. writl()
  252. {    drop();
  253.     if(ram[-31].in>0) merr(nopen);
  254.     Pc=stack[1+stkptr]; Pc2=Pc+*Pc-1;
  255.     while(Pc<Pc2) {Pc++;putc(*Pc,edout);}
  256.     fprintf(edout,"\n");/*CPM newline*/
  257.     ram[-31].in--;
  258. }
  259.  
  260. cordmp()
  261. {    fname(imagename);
  262.     temp=creat(1+imagename);
  263.     if(temp==ERROR) merr(nopen);
  264.     write(temp,nram,NSAVE);
  265.     close(temp);
  266. }
  267.  
  268. restor()
  269. {    fname(imagename);
  270.     temp=open(1+imagename,0);
  271.     if(temp==ERROR) merr(nopen);
  272.     read(temp,nram,NSAVE);
  273. }r+1])